home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / FRPOLY.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  5.8 KB  |  175 lines
  1. ; FRPOLY
  2.  
  3. (defvar *v*)
  4. (defvar *X*)
  5. (defvar *alpha*)
  6. (defvar *A*)
  7. (defvar *B*)
  8. (defvar *B*)
  9. (defvar *l)
  10. (defvar *p)
  11. (defvar q*)
  12. (defvar u*)
  13. (defvar *var)
  14. (defvar *y*)
  15. (defvar *R*)
  16. (defvar *r2*)
  17. (defvar *r3*)
  18.  
  19. ;(declare (localf pcoefadd pcplus pcplus1 pplus ptimes ptimes1
  20. ;         ptimes2 ptimes3 psimp pctimes pctimes1
  21. ;         pplus1))
  22.  
  23. (defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
  24. (defmacro pcoefp (e) `(atom ,e))
  25.  
  26. (defmacro pzerop (x) `(and (numberp ,x) (zerop ,x)))            ;true for 0 or 0.0
  27. ;(defmacro pzero () 0)
  28. (defmacro cplus (x y) `(+ ,x ,y))
  29. (defmacro ctimes (x y) `(* ,x ,y))
  30.  
  31. (defun pcoefadd (e c x)
  32.   (if (pzerop c)
  33.       x
  34.       (cons e (cons c x))))
  35.  
  36. (defun pcplus (c p)
  37.   (if (pcoefp p)
  38.       (cplus p c)
  39.       (psimp (car p) (pcplus1 c (cdr p)))))
  40.  
  41. (defun pcplus1 (c x)
  42.        (cond ((null x)
  43.           (cond ((pzerop c) nil) (t (cons 0 (cons c nil)))))
  44.          ((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil))
  45.          (t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))
  46.     
  47. (defun pctimes (c p) (cond ((pcoefp p) (ctimes c p))
  48.                (t (psimp (car p) (pctimes1 c (cdr p))))))
  49.  
  50. (defun pctimes1 (c x)
  51.        (cond ((null x) nil)
  52.          (t (pcoefadd (car x)
  53.               (ptimes c (cadr x))
  54.               (pctimes1 c (cddr x))))))
  55.  
  56. (defun pplus (x y) (cond ((pcoefp x) (pcplus x y))
  57.              ((pcoefp y) (pcplus y x))
  58.              ((eq (car x) (car y))
  59.               (psimp (car x) (pplus1 (cdr y) (cdr x))))
  60.              ((pointergp (car x) (car y))
  61.               (psimp (car x) (pcplus1 y (cdr x))))
  62.              (t (psimp (car y) (pcplus1 x (cdr y))))))
  63.  
  64. (defun pplus1 (x y)
  65.        (cond ((null x) y)
  66.          ((null y) x)
  67.          ((= (car x) (car y))
  68.           (pcoefadd (car x)
  69.             (pplus (cadr x) (cadr y))
  70.             (pplus1 (cddr x) (cddr y))))
  71.          ((> (car x) (car y))
  72.           (cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
  73.          (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))
  74.  
  75. (defun psimp (var x)
  76.        (cond ((null x) 0)
  77.          ((atom x) x)
  78.          ((zerop (car x)) (cadr x))
  79.           (t (cons var x))))
  80.  
  81. (defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) 0)
  82.               ((pcoefp x) (pctimes x y))
  83.               ((pcoefp y) (pctimes y x))
  84.               ((eq (car x) (car y))
  85.                (psimp (car x) (ptimes1 (cdr x) (cdr y))))
  86.               ((pointergp (car x) (car y))
  87.                (psimp (car x) (pctimes1 y (cdr x))))
  88.               (t (psimp (car y) (pctimes1 x (cdr y))))))
  89.  
  90. (defun ptimes1 (*x* y) (prog (u* *v*)
  91.                    (setq *v* (setq u* (ptimes2 y)))
  92.               a    (setq *x* (cddr *x*))
  93.                    (cond ((null *x*) (return u*)))
  94.                    (ptimes3 y)
  95.                    (go a)))
  96.  
  97. (defun ptimes2 (y) (cond ((null y) nil)
  98.              (t (pcoefadd (+ (car *x*) (car y))
  99.                       (ptimes (cadr *x*) (cadr y))
  100.                       (ptimes2 (cddr y))))))
  101.  
  102. (defun ptimes3 (y)
  103.   (prog (e u c)
  104.      a1 (cond ((null y) (return nil)))
  105.     (setq e (+ (car *x*) (car y)))
  106.     (setq c (ptimes (cadr y) (cadr *x*) ))
  107.     (cond ((pzerop c) (setq y (cddr y)) (go a1))
  108.           ((or (null *v*) (> e (car *v*)))
  109.            (setq u* (setq *v* (pplus1 u* (list e c))))
  110.            (setq y (cddr y)) (go a1))
  111.           ((= e (car *v*))
  112.            (setq c (pplus c (cadr *v*)))
  113.            (cond ((pzerop c) (setq u* (setq *v* (pdiffer1 u* (list (car *v*) (cadr *v*))))))
  114.              (t (rplaca (cdr *v*) c)))
  115.            (setq y (cddr y))
  116.            (go a1)))
  117.      a  (cond ((and (cddr *v*) (> (caddr *v*) e)) (setq *v* (cddr *v*)) (go a)))
  118.     (setq u (cdr *v*))
  119.      b  (cond ((or (null (cdr u)) (< (cadr u) e))
  120.            (rplacd u (cons e (cons c (cdr u)))) (go e)))
  121.     (cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d))
  122.           (t (rplaca (cddr u) c)))
  123.      e  (setq u (cddr u))
  124.      d  (setq y (cddr y))
  125.     (cond ((null y) (return nil)))
  126.     (setq e (+ (car *x*) (car y)))
  127.     (Setq c (ptimes (cadr y) (cadr *x*)))
  128.      c  (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c)))
  129.     (go b)))
  130.  
  131. ;; pdiffer1 is referred to above but not defined.  RPG says it is never called.
  132. (defun pdiffer1 (x y) x y (error "pdiffer2 called"))
  133.  
  134. (defun pexptsq (p n)
  135.     (do ((n (floor n 2) (floor n 2))
  136.          (s (cond ((oddp n) p) (t 1))))
  137.         ((zerop n) s)
  138.         (setq p (ptimes p p))
  139.         (and (oddp n) (setq s (ptimes s p))) ))
  140.  
  141. (defun setup-frpoly nil
  142.   (setf (get 'x 'order ) 1)
  143.   (setf (get 'y 'order ) 2)
  144.   (setf (get 'z 'order ) 3)
  145.   (setq *r* (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1
  146.   (setq *r2* (ptimes *r* 100000)) ;r2 = 100000*r
  147.   (setq *r3* (ptimes *r* 1.0)); r3 = r with floating point coefficients
  148.   )
  149.  
  150. (setup-frpoly)
  151.  
  152. (define-timer frpoly2r "FRPoly, Power = 2, r = x + y + z + 1" (pexptsq *r* 2))
  153. (define-timer frpoly2r2 "FRPoly, Power = 2, r2 = 1000r" (pexptsq *r2* 2))
  154. (define-timer frpoly2r3 "FRPoly, Power = 2, r3 = r in flonums" (pexptsq *r3* 2))
  155.  
  156. (qa-attempt "FRPoly, Power = 2, r = x + y + z + 1" (pexptsq *r* 2)
  157.  (Z 2 1 1 (Y 1 2 0 (X 1 2 0 2)) 0 (Y 2 1 1 (X 1 2 0 2) 0 (X 2 1 1 3 0 1))))
  158.  
  159.  
  160. (qa-attempt "FRPoly, Power = 2, r3 = r in flonums" (pexptsq *r3* 2)
  161.  (Z 2 1.0 1 (Y 1 2.0 0 (X 1 2.0 0 2.0)) 0
  162.       (Y 2 1.0 1 (X 1 2.0 0 2.0) 0 (X 2 1.0 1 3.0 0 1.0))))
  163.  
  164. (define-timer frpoly5r "FRPoly, Power = 5, r = x + y + z + 1" (pexptsq *r* 5))
  165. (define-timer frpoly5r2 "FRPoly, Power = 5, r2 = 1000r" (pexptsq *r2* 5))
  166. (define-timer frpoly5r3 "FRPoly, Power = 5, r3 = r in flonums" (pexptsq *r3* 5))
  167.  
  168. (define-timer frpoly10r "FRPoly, Power = 10, r = x + y + z + 1" (pexptsq *r* 10))
  169. (define-timer frpoly10r2 "FRPoly, Power = 10, r2 = 1000r" (pexptsq *r2* 10))
  170. (define-timer frpoly10r3 "FRPoly, Power = 10, r3 = r in flonums" (pexptsq *r3* 10))
  171.  
  172. (define-timer frpoly15r "FRPoly, Power = 15, r = x + y + z + 1" (pexptsq *r* 15))
  173. (define-timer frpoly15r2 "FRPoly, Power = 15, r2 = 1000r" (pexptsq *r2* 15))
  174. (define-timer frpoly15r3 "FRPoly, Power = 15, r3 = r in flonums" (pexptsq *r3* 15))
  175.